ETO Development Tools 2/ETO Development Tools 2.iso/Tools - Objects/MacApp/MacApp CD Release/MacApp 2.0.1 (Hard Disk Ready)/Examples/DrawShapes/UMenu.inc1.p

Text File | 1990-10-25 | 14.5 KB | 654 lines | [TEXT/MPS ]

{[a-,body+,h-,o=100,r+,rec+,t=4,u+,#+,j=20/57/1$,n-]}

TYPE
    MenuRec             = RECORD
        mID:                INTEGER;
        mObject:            TMenu;
        END;
    MenuArray            = ARRAY [1..4000] OF MenuRec;
    MenuArrayPtr        = ^MenuArray;
    MenuArrayHandle     = ^MenuArrayPtr;

VAR
    pMenuCPort:         CGrafPort;                        { Color port for compatibility. }
                                                        { Private grafPort used to focus the menu w/o
                                                         messing up the Window Manager port. }
    pMenuArray:         MenuArrayHandle;                { Used to find the TMenu given a MenuHandle.
                                                         }
    pNumMenus:            INTEGER;

    pCustDefproc:        Handle;                         { Replaces the menu's menuProc field }

{--------------------------------------------------------------------------------------------------}
    { Returns the TickCount some time in the future. }

FUNCTION Future(delta: LONGINT): LONGINT;

    BEGIN
    Future := TickCount + delta;
    END;

{--------------------------------------------------------------------------------------------------}

{$S ARes}

PROCEDURE WaitTickChange;

    VAR
        now:                LONGINT;

    BEGIN
    now := TickCount;
    REPEAT
    UNTIL TickCount <> now;
    END;

{--------------------------------------------------------------------------------------------------}

{$S ARes}

FUNCTION FindTMenu(theMenu: MenuHandle): TMenu;

    VAR
        i:                    INTEGER;
        p:                    MenuArrayPtr;
        id:                 INTEGER;

    BEGIN
    FindTMenu := NIL;
    p := pMenuArray^;
    id := theMenu^^.menuID;

    FOR i := 1 TO pNumMenus DO
        WITH p^[i] DO
            IF mID = id THEN
                BEGIN
                FindTMenu := mObject;
                Exit(FindTMenu);
                END;
    END;

{--------------------------------------------------------------------------------------------------}
{ Called by the MDEF resource. }
{$Push} {$IFC qTrace} {$D+} {$ENDC}

{$S ARes}

PROCEDURE MenuDefproc(message: INTEGER;
                      theMenu: MenuHandle;
                      VAR menuRect: Rect;
                      hitPt: Point;
                      VAR whichItem: INTEGER);

    VAR
        menuObj:            TMenu;
        OldA5:                Longint;

    BEGIN
    OldA5 := SetCurrentA5;                                { ***** Called from trap patches *****}
    menuObj := FindTMenu(theMenu);
    {$IFC qDebug}
    IF menuObj = NIL THEN
        ProgramBreak('MenuDefproc called with no TMenu object');
    {$ENDC}

    { Dispatch to the TMenu object }
    menuObj.HandleDefproc(message, theMenu, menuRect, hitPt, whichItem);
    OldA5 := SetA5(OldA5);
    END;
{$Pop}

{--------------------------------------------------------------------------------------------------}
{$S AInit}

PROCEDURE InitUMenu;

    TYPE
        JMP                 = RECORD
            opcode:             INTEGER;
            address:            Ptr;
            END;
        JmpPtr                = ^JMP;
        JmpHandle            = ^JmpPtr;

    VAR
        h:                    JmpHandle;

    BEGIN
    IF qNeedsColorQD | gConfiguration.hasColorQD THEN
        OpenCPort(@pMenuCPort)
    ELSE
        OpenPort(GrafPtr(@pMenuCPort));
    pNumMenus := 0;
    pMenuArray := MenuArrayHandle(NewHandle(0));
    FailNIL(pMenuArray);

    h := JmpHandle(NewHandle(6));
    FailNIL(h);
    WITH h^^ DO
        BEGIN
        opcode := $4EF9;
        address := @MenuDefproc;
        END;
    pCustDefproc := Handle(h);
    END;

{--------------------------------------------------------------------------------------------------}
{$S AInit}

PROCEDURE TMenu.IMenu(rsrcID: INTEGER;
                      menuWidth, menuHeight: INTEGER);

    VAR
        m:                    MenuHandle;
        s:                    LONGINT;
        p:                    LongintPtr;
        i:                    INTEGER;

        r:                    Rect;
        item:                INTEGER;
        vp:                 VPoint;

    BEGIN
    { Initialize fields }
    fBorder := gZeroRect;
    fMenuHandle := NIL;
    vp.h := menuWidth;
    vp.v := menuHeight;
    IView(NIL, NIL, gZeroVPt, vp, SizeVariable, SizeVariable);

    fFlashInterval := - 1;
    fNextFlash := 0;

    IF rsrcID = 0 THEN
        fMenuHandle := NIL
    ELSE
        BEGIN
        { Read in menu and set its defproc }
        m := MenuHandle(GetResMenu(rsrcID));

        IF m = NIL THEN
            BEGIN
            {$IFC qDebug}
            Writeln('rsrcID = ', rsrcID: 1);
            ProgramBreak('No such MENU!');
            {$ENDC}

            Free;
            Failure(resNotFound, 0);
            END;

        pNumMenus := pNumMenus + 1;
        SetHandleSize(Handle(pMenuArray), SIZEOF(MenuRec) * pNumMenus);
        WITH pMenuArray^^[pNumMenus] DO
            BEGIN
            mID := m^^.menuID;
            mObject := SELF;
            END;

        m^^.menuProc := pCustDefproc;
        fMenuHandle := m;

        MenuDefproc(mSizeMsg, m, r, Point(0), item);    { recompute the menu size }
        END;
    END;

{--------------------------------------------------------------------------------------------------}
{$S MenuNever}

FUNCTION TMenu.FindItem(hitPt: Point): INTEGER;

    BEGIN
    {$IFC qDebug}
    ProgramBreak('You must override TMenu.FindItem.');
    {$ENDC}
    END;

{--------------------------------------------------------------------------------------------------}
{$S ARes}

PROCEDURE TMenu.HandleDefproc(message: INTEGER;
                              theMenu: MenuHandle;
                              VAR menuRect: Rect;
                              hitPt: Point;
                              VAR whichItem: INTEGER);

    VAR
        p:                    LongintPtr;
        savePort:            GrafPtr;
        r:                    Rect;

    BEGIN
    { Save the wmgr port & set our private port }
    GetPort(savePort);

    fMenuRect := menuRect;
    fHitPt := hitPt;

    IF Focus THEN
        BEGIN
        hitPt := fHitPt;

        ViewEnable(Odd(fMenuHandle^^.enableFlags), false {no redraw} );
        CASE message OF
            mDrawMsg:
                BEGIN
                {$IFC qDebug}
                IF gIntenseDebugging THEN
                    Writeln('mDrawMsg');
                {$ENDC}
                HandleDrawMessage(message, theMenu, menuRect, hitPt, whichItem);
                END;

            mChooseMsg:
                BEGIN
                {$IFC qDebug}
                IF gIntenseDebugging THEN
                    Writeln('mChooseMsg');
                {$ENDC}
                HandleChooseMessage(message, theMenu, menuRect, hitPt, whichItem);
                END;

            mSizeMsg:
                BEGIN
                {$IFC qDebug}
                IF gIntenseDebugging THEN
                    Writeln('mSizeMsg');
                {$ENDC}
                HandleSizeMessage(message, theMenu, menuRect, hitPt, whichItem);
                END;

            mPopUpMsg:
                BEGIN
                {$IFC qDebug}
                IF gIntenseDebugging THEN
                    Writeln('mPopUpMsg');
                {$ENDC}
                HandlePopUpMessage(message, theMenu, menuRect, hitPt, whichItem);
                END;
            {$IFC qDebug}
            OTHERWISE
                IF gIntenseDebugging THEN
                    Writeln('otherwise message');
            {$ENDC}
        END;
        InvalidateFocus;
        END;

    SetPort(savePort);
    END;

{--------------------------------------------------------------------------------------------------}
{$S ARes}

PROCEDURE TMenu.HandleChooseMessage(message: INTEGER;
                                    theMenu: MenuHandle;
                                    VAR menuRect: Rect;
                                    hitPt: Point;
                                    VAR whichItem: INTEGER);

    VAR
        newItem:            INTEGER;
        hitRect:            Rect;

    BEGIN
    newItem := kNoMenuItem;                             { default return }

    { See what item the user is over }

    IF IsViewEnabled THEN                                { menu enabled }
        BEGIN
        { see if point is within hit area }
        GetQDExtent(hitRect);
        AddPt(fBorder.topLeft, hitRect.topLeft);
        AddPt(fBorder.botRight, hitRect.botRight);

        IF PtInRect(hitPt, hitRect) THEN                { in menu (not border) }
            newItem := FindItem(hitPt);
        END;

    { Update highlighting }
    UpdateHighlight(whichItem, newItem);

    { Tell MenuManager about new item }
    whichItem := newItem;
    END;

{--------------------------------------------------------------------------------------------------}
{$S ARes}

PROCEDURE TMenu.HandleDrawMessage(message: INTEGER;
                                  theMenu: MenuHandle;
                                  VAR menuRect: Rect;
                                  hitPt: Point;
                                  VAR whichItem: INTEGER);
    var
        extent: Rect;

    BEGIN
    DrawContents;
    fHighlighted := false;
    if not fViewEnabled THEN
        begin
        PenPat(Gray);
        PenMode(notSrcBic);
        GetQDExtent(extent);
        PaintRect(extent);
        end;
    END;

{--------------------------------------------------------------------------------------------------}
{$S ARes}

PROCEDURE TMenu.HandleSizeMessage(message: INTEGER;
                                  theMenu: MenuHandle;
                                  VAR menuRect: Rect;
                                  hitPt: Point;
                                  VAR whichItem: INTEGER);

    VAR
        vp:                 VPoint;

    BEGIN
    ComputeSize(vp);
    fMenuHandle^^.menuWidth := vp.h;
    fMenuHandle^^.menuHeight := vp.v;
    END;

{--------------------------------------------------------------------------------------------------}
{$S ARes}

PROCEDURE TMenu.HandlePopUpMessage(message: INTEGER;
                                   theMenu: MenuHandle;
                                   VAR menuRect: Rect;
                                   hitPt: Point;
                                   VAR whichItem: INTEGER);

    VAR
        vp:                 VPoint;

    BEGIN
    {  SubPt(origin, hitPt);}

    menuRect.top := hitPt.h;
    menuRect.left := hitPt.v;
    ComputeSize(vp);
    menuRect.bottom := menuRect.top + vp.v;
    menuRect.right := menuRect.left + vp.h;
    END;

{--------------------------------------------------------------------------------------------------}
{$S ARes}

PROCEDURE TMenu.Highlight(whichItem: INTEGER;
                          turnItOn: BOOLEAN);

    BEGIN
    {$IFC qDebug}
    ProgramBreak('You must override TMenu.Highlight.');
    {$ENDC}
    END;

{--------------------------------------------------------------------------------------------------}
{$S AFields}

PROCEDURE TMenu.Fields(PROCEDURE DoToField(fieldName: Str255;
                                           fieldAddr: Ptr;
                                           fieldType: INTEGER)); OVERRIDE;

    BEGIN
    DoToField('fFlashInterval', @fFlashInterval, bLongInt);
    DoToField('fNextFlash', @fNextFlash, bLongInt);
    DoToField('fHighlighted', @fHighlighted, bBoolean);
    DoToField('fMenuHandle', @fMenuHandle, bHandle);
    DoToField('fBorder', @fBorder, bRect);

    INHERITED Fields(DoToField);
    END;

{--------------------------------------------------------------------------------------------------}
{$S ARes}
FUNCTION TMenu.IsItemEnabled(item:INTEGER): Boolean;

    BEGIN
    IsItemEnabled := BTst(fMenuHandle^^.enableFlags, item)
    END;

{--------------------------------------------------------------------------------------------------}
{$S ARes}

PROCEDURE TMenu.GetMenuColors(theMenu, theItem: INTEGER; VAR theMenuColors: MenuColors);

    TYPE
        TypeOfMenuInfo = (aMenuItem, aMenuTitle, aMenuBar, noType);

    VAR
        aMCEntryPtr: MCEntryPtr;
        typeOfRequest: TypeOfMenuInfo;
        typeOfEntryFound: TypeOfMenuInfo;
        theEntryMenu, theEntryItem: INTEGER;

    BEGIN
    WITH theMenuColors DO
        BEGIN
        IF qNeedsColorQD | gConfiguration.hasColorQD THEN
            BEGIN
            IF theItem <> 0 THEN
                typeOfRequest := aMenuItem
            ELSE IF theMenu <> 0 THEN
                typeOfRequest := aMenuTitle
            ELSE
                typeOfRequest := aMenuBar;

            theEntryMenu := theMenu;
            theEntryItem := theItem;

            aMCEntryPtr := GetMCEntry(theEntryMenu, theEntryItem);
            IF aMCEntryPtr = NIL THEN { not found, try as title }
                BEGIN
                theEntryItem := 0;
                aMCEntryPtr := GetMCEntry(theEntryMenu, theEntryItem);
                IF aMCEntryPtr = NIL THEN { not found, try as menubar }
                    BEGIN
                    theEntryMenu := 0;
                    aMCEntryPtr := GetMCEntry(theEntryMenu, theEntryItem);
                    END;
                END;

            IF aMCEntryPtr = NIL THEN
                typeOfEntryFound := noType
            ELSE
                BEGIN
                IF theEntryItem <> 0 THEN
                    typeOfEntryFound := aMenuItem
                ELSE IF theEntryMenu <> 0 THEN
                    typeOfEntryFound := aMenuTitle
                ELSE
                    typeOfEntryFound := aMenuBar;
                END;

            CASE typeOfEntryFound OF
                aMenuItem:
                    WITH aMCEntryPtr^ DO
                        BEGIN
                        itemColor := mctRGB1;
                        backgroundColor := mctRGB4;
                        markColor := mctRGB1;
                        commandColor := mctRGB1;
                        END;
                aMenuTitle:
                    CASE typeOfRequest OF
                        aMenuItem:
                            WITH aMCEntryPtr^ DO
                                BEGIN
                                itemColor := mctRGB3;
                                backgroundColor := mctRGB4;
                                markColor := mctRGB3;
                                commandColor := mctRGB3;
                                END;
                        aMenuTitle:
                            WITH aMCEntryPtr^ DO
                                BEGIN
                                itemColor := mctRGB1;
                                backgroundColor := mctRGB2;
                                markColor := mctRGB1;
                                commandColor := mctRGB1;
                                END;
                    END;
                aMenuBar:
                    CASE typeOfRequest OF
                        aMenuItem:
                            WITH aMCEntryPtr^ DO
                                BEGIN
                                itemColor := mctRGB3;
                                backgroundColor := mctRGB2;
                                markColor := mctRGB3;
                                commandColor := mctRGB3;
                                END;
                        aMenuTitle:
                            WITH aMCEntryPtr^ DO
                                BEGIN
                                itemColor := mctRGB1;
                                backgroundColor := mctRGB4;
                                markColor := mctRGB1;
                                commandColor := mctRGB1;
                                END;
                        aMenuBar:
                            WITH aMCEntryPtr^ DO
                                BEGIN
                                itemColor := mctRGB1;
                                backgroundColor := mctRGB4;
                                markColor := mctRGB1;
                                commandColor := mctRGB1;
                                END;
                    END;
                noType:
                    BEGIN
                    itemColor := gRGBBlack;
                    backgroundColor := gRGBWhite;
                    markColor := gRGBBlack;
                    commandColor := gRGBBlack;
                    END;
            END;
            END
        ELSE
            BEGIN
            itemColor := gRGBBlack;
            backgroundColor := gRGBWhite;
            markColor := gRGBBlack;
            commandColor := gRGBBlack;
            END;
        END;
    END;

{--------------------------------------------------------------------------------------------------}
{$S ARes}

PROCEDURE TMenu.UpdateHighlight(oldItem, newItem: INTEGER);

    BEGIN
    { Update highlighting }
    IF newItem <> oldItem THEN
        BEGIN
        IF fHighlighted THEN
            IF oldItem <> kNoMenuItem THEN
                Highlight(oldItem, false);

        fHighlighted := newItem <> kNoMenuItem;
        IF fHighlighted THEN
            Highlight(newItem, TRUE);

        IF fFlashInterval >= 0 THEN
            fNextFlash := Future(fFlashInterval);
        END

    ELSE IF fFlashInterval >= 0 THEN
        IF TickCount > fNextFlash THEN
            BEGIN
            fHighlighted := NOT fHighlighted;
            Highlight(oldItem, fHighlighted);
            fNextFlash := Future(fFlashInterval);
            END;
    END;

{--------------------------------------------------------------------------------------------------}
{$S ARes}

FUNCTION TMenu.Focus: BOOLEAN; OVERRIDE;

    VAR
        r:                    Rect;
        vorigin:            VPoint;
        origin:             Point;
        {$IFC qDebug}
        currentPort:        GrafPtr;
        {$ENDC}
        theMenuColors:        MenuColors;

    BEGIN
    IF IsFocused THEN
        BEGIN
        {$IFC FALSE}
        IF LONGINT(pMenuCPort.portRect.topLeft) <> 0 THEN
            ProgramBreak('TMenu.Focus: Origin is not (0,0)');

        GetPort(currentPort);
        IF currentPort <> @pMenuCPort THEN
            ProgramBreak('TMenu.Focus: Port is incorrect');
        {$ENDC}
        END
    ELSE                                                {IF @pMenuCPort <> NIL THEN}
        BEGIN
        IF qNeedsColorQD | gConfiguration.hasColorQD THEN
            InitCPort(@pMenuCPort)
        ELSE
            InitPort(GrafPtr(@pMenuCPort));             { set the port to default settings }

        SetPort(@pMenuCPort);
        gLongOffset := gZeroVPt;



        { Try to make the best match for the menu colors without requiring programmer intervention.
        by setting the color environment to be for items. }

        GetMenuColors(fMenuHandle^^.menuID, 1, theMenuColors);
        SetIfColor(theMenuColors.itemColor);
        SetIfBkColor(theMenuColors.backgroundColor);

        { Change the origin so that drawing is relative to fLocation }
        {$Push}{$H-}
        origin := VPtToPt(fLocation);
        {$Pop}

        SubPt(fMenuRect.topLeft, origin);
        SetOrigin(origin.h, origin.v);

        {$Push}{$H-}
        AddPt(origin, fHitPt);
        OffsetRect(fMenuRect, origin.h, origin.v);
        ClipRect(fMenuRect);
        {$Pop}
        gFocusedView := SELF;
        END;
    Focus := TRUE;
    END;

{--------------------------------------------------------------------------------------------------}
{$S ARes}

FUNCTION TMenu.FocusOnSuperView: BOOLEAN; OVERRIDE;

    BEGIN
    FocusOnSuperView := false;
    END;

{--------------------------------------------------------------------------------------------------}
{$S ARes}

FUNCTION TMenu.GetGrafPort: GrafPtr; OVERRIDE;

    BEGIN
    GetGrafPort := GrafPtr(@pMenuCPort);
    END;